﻿{-# OPTIONS_GHC -XRecordWildCards #-}
module XI.Directory.Parser where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language(haskellDef)
import XI.Directory.Types
import Data.Maybe
import Data.List
import Data.Ord(comparing)
import Control.Arrow

whiteSpace= P.whiteSpace lexer
squares = P.squares lexer
lexeme = P.lexeme lexer
identifier= P.identifier lexer
reserved = P.reserved lexer
reservedOp= P.reservedOp lexer

uri = lexeme $ do 
  s0 	<- string "http://" <|> string "urn:"
  s 	<- many1 (letter <|> digit <|> oneOf "_-./:") <?> "uri" 
  return $ s0 ++ s
  
condition = lexeme (string "-" <?> "condition")
scid = lexeme (many1 (letter <|> digit <|> oneOf "|_./:-*") <?> "scenario object id (scid)")
adapterType = do {at<-identifier; (return $ readAT at) <?> 
  "adapterType (JMS | JDBC | File | FTP | RFC | IDoc | HTTP | XI | SOAP | RNIF | CIDX | Mail | Marketplace | BC)"} 
  -- сообщение не работает!

lexer = P.makeTokenParser $ haskellDef {P.reservedNames = ["BEGIN","END", "+CC", "+Sc", "+Agg", "+RD", "+ID", "[IntegrationProcesses]", "S", "R"]}

parseDir :: Parser Configuration
parseDir = do {
  whiteSpace;	x<-do {
    zc<-lexeme $ many $ do {
      s<-option Nothing $ reserved "BEGIN" >> identifier >>= return . Just;
      chains<-many1 $ do {
        bss<-identifier; ccs<-lexeme $ identifier <|> string "-"; mis<-uri;  reservedOp "=>";
        rcvs<-many1 $ do {
          cond<-condition; bs<-identifier; 
          rints<-many1 $ do {
            mi<-uri; im<-lexeme $ string "-" <|> uri; ccr<-lexeme $ identifier <|>string "-"; cond<-condition; 
                        return RcvInt { ri_cond = getMb Condition cond, 
                                        r_int = mi, 
                                        mapping = getMb id im, 
                                        r_cc = ccr}
          }; 
          return Receiver {r_cond = getMb Condition cond, r_sys = bs, r_ints = rints}
        };
        return $ Chain (Sender {s_sys = bss, s_cc = ccs, s_int = mis}) rcvs
      };
      if s == Nothing then return () else reserved "END";
      return Scenario { scenario_name = s,
                        scenario_chains = chains }
    };
    zu<-lexeme $ many (do { 
      (lexeme $ do {reserved "+CC"; s<-identifier; cc<-identifier; t<-getType; at<-adapterType;
                    return CC {	cc_system = s,
                                cc_name = cc,
                                cc_param = (t, at) } }) <|>
      (lexeme $ do {reserved "+Sc"; sc<-identifier; xx<-squares $ many $ lexeme $ scid; 
            return Sc {	sc_name = sc,
                        sc_ids = xx }}) <|>
      (lexeme $ do {reserved "+Agg"; t<-getType; 
        ss <- if t == CCSender then return "" else lexeme $ identifier <|> string "*";
        s<-identifier; mi<-lexeme $ uri <|> string "*/*"; cc<-identifier;  
        return $ if t == CCSender then SAgg {	sender = s,
                                              sender_int = mi,
                                              sender_cc = cc } 
                                  else RAgg { sender = ss,
                                              receiver = s,
                                              receiver_int = mi,
                                              receiver_cc = cc } }) <|>
      (lexeme $ do {reserved "+RD"; s <- identifier; mi <- uri; ss <- many1 $ 
        do {cond <- condition; i <- identifier; return (getMb Condition cond, i)}; 
          return RD {	sender = s,
                      sender_int = mi,
                      cond_receivers = ss }}) <|>
      (lexeme $ do {reserved "+ID"; s <- lexeme $ identifier <|> string "*"; mi<-uri; r <- lexeme $ identifier <|> string "*"; 
        ss<-many1 $ do {cond<-condition; u<-uri; m<-lexeme $ string "-" <|> uri; return (getMb Condition cond, u, getMb id m)};
        return ID {	sender = s,
                    sender_int = mi,
                    receiver = r,
                    cond_receiver_ints = ss } })
    });
    sccs<-lexeme $ many $ lexeme $ do {string "+"; s<-identifier; many1 $ do {cc<-identifier; t<-getType; at<-adapterType; 
        return CC {	cc_system = s,
                    cc_name = cc,
                    cc_param = (t, at) }}};
    ips <- lexeme $ reserved "[IntegrationProcesses]" >> (lexeme $ many $ lexeme $ identifier >>= return . IP);
    return (nub zc, nub zu ++ (concat sccs) ++ ips);
  }; eof; return x;
}
  where 
    getMb f x = if x == "-" then Nothing else Just $ f x
    getType = (reserved "S" >> return CCSender) <|> (reserved "R" >> return CCReceiver)
    getTypeCC s cc zc zu = if 
        (not . null . filter (not . null . filter ((== (s, cc)) . (\(Sender {..}) -> (s_cc, s_sys)) . chain_sender) . scenario_chains) $ zc) || 
        (not . null . filter (\(CC {..}) -> (cc_system, cc_name, fst cc_param) == (s, cc, CCSender)) . filter isCC $ zu) 
        then CCSender else CCReceiver

scriptDir::Configuration->[String]
scriptDir (scs, xos) = 
  ["-- chains", ""] ++
  concatMap fsc scs ++ 
  ["", "", "-- unchained", ""] ++
  (map (('+':) . show) $ filter (not . flip any [isCC, isIP] . flip ($)) xos) ++ 
  ["", "", "-- communication channels", ""] ++
  (concatMap fcch $ foldr foldcch [] $ sortBy (comparing cc_system) $ filter isCC xos) ++ 
  ["", "", "[IntegrationProcesses]", ""] ++
    (map ((drop 3) . show) $ filter isIP xos)
  where 
    fsc (Scenario sc chains) = 
      (if sc == Nothing then [] else ["BEGIN " ++ (fromJust sc)]) ++
      (concat $ map (fch $ sc /= Nothing) chains) ++
      (if sc == Nothing then ["\n"] else ["END\n"])
    fch isShift (Chain sender receivers) = (fsender isShift sender) ++ (concatMap (frcv isShift) receivers)
    fsender isShift (Sender sys cc int) = [shift isShift ++ sys ++ " " ++ cc ++ " " ++ int ++ " => "]
    frcv isShift (Receiver cond sys ints) = 
      [shift isShift ++ "\t" ++ showCond cond ++ " " ++ sys] ++
      (concat $ map (frint isShift) ints)
    frint isShift (RcvInt cond int m cc) = [shift isShift ++ "\t\t" ++ int ++ " " ++ 
      fromMaybe "-" m ++ " " ++ cc ++ " " ++ showCond cond]
    showCond c = if c == Nothing then "-" else show $ fromJust c
    shift isShift = if isShift then "\t" else "" 
    
    foldcch (CC s cc par) [] = [(s, [(cc, par)])]
    foldcch (CC s cc par) xs@((hs, hccs):txs) = if s == hs then (hs, (cc,par):hccs):txs else (s, [(cc,par)]):xs
    fcch (s, cchs) = map (filter (/='"')) $ ["+" ++ show s] ++ map (\(cc, (t, at))->"\t" ++ (show cc) ++ " " ++ (show t) ++ " " ++ (show at)) cchs
